Delphi 2 - Developers' Solutions/Delphi 2 Developers' Solutions.iso/dds/comps/widgets/delphi10/ulbmpimg/ulbmpimg.pas

Pascal/Delphi Source File | 1996-06-16 | 8.5 KB | 308 lines

unit Ulbmpimg;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls;

type
  ULIFile_Bitmap = class( TObject )
  public
    Bitmap_Handle    : HBitmap;   { Holds the DIB when done               }
    Width            : Longint;   { Holds the pixel width when done       }
    Height           : Longint;   { Holds the pixel height when done      }
    The_File         : File;      { File variable for internal use        }
    The_Name         : String;    { Holds the file name                   }
    Bits_Handle      : THandle;   { temporary holder for the DIB          }
    Bits_Byte_Size   : Longint;   { temporary holder for the              }
                                  { byte length of the DIB                }
    Error_Status     : Integer;   { code for error condition on the DIB   }

    constructor Create;
    procedure Initialize( The_DIB_Name : String );
    destructor Destroy;
    procedure Get_Bitmap_Data;
    function Get_Bitmap : HBitmap;
    function Load_Bitmap_File : Boolean;
    function Open_DIB : Boolean;
    function Get_Error_Status : Integer;
    procedure Get_DIB_Dimensions( var The_Width  ,
                                      The_Height   : Longint );
  end;
  TUnlimitedBitmapImage = class(TImage)
  private
    { Private declarations }
    FTheFileName : String;
    TheULBMP  : ULIFile_Bitmap;
  protected
    { Protected declarations }
    OldFileName : String;
    TheBitmap : TBitmap;
    valid_load : Boolean;
  public
    { Public declarations }
    constructor Create( AOwner : TComponent ); override;
    destructor Destroy; override;
    procedure Paint; override;
    procedure LoadULBMPFile;
  published
    { Published declarations }
    property TheFileName : String read FTheFileName write FTheFileName;
  end;

procedure Register;

implementation

procedure AHIncr; FAR; EXTERNAL 'KERNEL' INDEX 114;

{ This creates a file bitmap object }
constructor ULIFile_Bitmap.Create;
begin
  { call inherited FIRST! }
  inherited Create;
  { Zero out the data elements }
  Bitmap_Handle := 0;
  The_Name := '';
end;

{ This procedure sets up the bitmap filename to load }
procedure ULIFile_Bitmap.Initialize( The_DIB_Name : String );
begin
  The_Name := The_DIB_Name;
end;

{ This is the destructor procedure }
destructor ULIFile_Bitmap.Destroy;
begin
  { Assume bitmap handle given to TBitmap and cleared there }
  { call inherited last }
  inherited destroy;
end;

{ This method copies the bitmap bits data from the file into memory. Since }
{ copying cannot cross a segment (64K) boundary, segment arithmetic must   }
{ be done on the fly.  A LongType type was created to simplify this process}
procedure ULIFile_Bitmap.Get_Bitmap_Data;

type
  LongType = record
  case Word of
    0: ( Ptr  : Pointer );
    1: ( Long : Longint );
    2: ( Lo   : Word;
         Hi   : Word    );
  end;
var
  Count   : Longint;
  Start,
  ToAddr,
  Bits    : LongType;
begin
  Start.Long := 0;
  Bits.Ptr := GlobalLock( Bits_Handle );
  Count := Bits_Byte_Size - Start.Long;
  while Count > 0 do
  begin
    ToAddr.Hi := Bits.Hi + ( Start.Hi * OFS( AHIncr ));
    ToAddr.Lo := Start.Lo;
    if Count > $4000 then Count := $4000;
    BlockRead( The_File , ToAddr.Ptr^ , Count );
    Start.Long := Start.Long + Count;
    Count := Bits_Byte_Size - Start.Long;
  end;
  GlobalUnlock( Bits_Handle );
end;

{ This returns the handle to the stored bitmap }
function ULIFile_Bitmap.Get_Bitmap : HBitmap;
begin
  Get_Bitmap := Bitmap_Handle;
end;

{ This is the function to call to load a bitmap file of any size }
{ If no errors occur it returns true, otherwise false; use GEC   }
{ (Some portions of this code are copyright Borland Intl, 1990.) }
function ULIFile_Bitmap.Load_Bitmap_File : Boolean;
var
  Test_Win30_Bitmap : Longint;
  Memory_DC         : HDC;
  The_IO_Result     : Word;
begin
  Error_Status := 0;
  Load_Bitmap_File := false;
  AssignFile( The_File , The_Name );
  {$I-}
  Reset( The_File , 1 );
  Seek( The_File , 14 );
  BlockRead( The_File , Test_Win30_Bitmap , SizeOf( Test_Win30_Bitmap ));
  {$I+}
  The_IO_Result := IOResult;
  If The_IO_Result <> 0 then
  begin
    Error_Status := -1;
  end
  else
  begin
    if Test_Win30_Bitmap = 40 then
    begin
      if Open_DIB then
      begin
        Load_Bitmap_File := true;
      end;
    end
    else
    begin
      Error_Status := -2;
    end;
    CloseFile( The_File );
  end;
end;

{ This does the actual loading of the bitmap's info }
function ULIFile_Bitmap.Open_DIB : Boolean;
var
  Bit_Count         : Word;
  Size              : Word;
  Long_Width        : Longint;
  DC_Handle         : HDC;
  Bits_Ptr          : Pointer;
  Bitmap_Info       : PBitmapInfo;
  New_Bitmap_Handle : THandle;
  New_Pixel_Width,
  New_Pixel_Height  : Word;
begin
  Open_DIB := true;
  Seek( The_File , 28 );
  BlockRead( The_File , Bit_Count , SizeOf( Bit_Count ));
  if Bit_Count <= 8 then
  begin
    Size := SizeOf( TBitmapInfoHeader ) + (( 1 SHL Bit_Count )
     * SizeOf( TRGBQuad ));
    Bitmap_Info := MemAlloc( Size );
    Seek( The_File , SizeOf( TBitmapFileHeader ));
    BlockRead( The_File , Bitmap_Info^ , Size );
    New_Pixel_Width := Bitmap_Info^.bmiHeader.biWidth;
    New_Pixel_Height := Bitmap_Info^.bmiHeader.biHeight;
    Long_Width := ((( New_Pixel_Width * Bit_Count ) + 31 ) div 32 ) * 4;
    Bitmap_Info^.bmiHeader.biSizeImage := Long_Width * New_Pixel_Height;
    {GlobalCompact( -1 );}
    Bits_Handle := GlobalAlloc( gmem_Moveable or gmem_Zeroinit ,
                                Bitmap_Info^.bmiHeader.biSizeImage );
    Bits_Byte_Size := Bitmap_Info^.bmiHeader.biSizeImage;
    Get_Bitmap_Data;
    DC_Handle := CreateDC( 'Display' , nil , nil , nil );
    Bits_Ptr := GlobalLock( Bits_Handle );
    New_Bitmap_Handle :=
    CreateDIBitmap( DC_Handle , Bitmap_Info^.bmiHeader ,
                    cbm_Init , Bits_Ptr , Bitmap_Info^ , 0 );
    DeleteDC( DC_Handle );
    GlobalUnlock( Bits_Handle );
    GlobalFree( Bits_Handle );
    FreeMem( Bitmap_Info , Size );
    if New_Bitmap_Handle <> 0 then
    begin
      if Bitmap_Handle <> 0 then DeleteObject( Bitmap_Handle );
      Bitmap_Handle := New_Bitmap_Handle;
      Width := New_Pixel_Width;
      Height := New_Pixel_Height;
    end
    else
    begin
      Open_DIB := false;
      Error_Status := -4;
    end;
  end
  else
  begin
    Open_DIB := false;
    Error_Status := -3;
  end;
end;

{ This is an OOP return of the error variable }
function ULIFile_Bitmap.Get_Error_Status : Integer;
begin
  Get_Error_Status := Error_Status;
end;

{ This is an OOP return of the dimensions of the DIB }
procedure ULIFile_Bitmap.Get_DIB_Dimensions( var The_Width  ,
                                              The_Height   : Longint );
begin
  The_Width := Width;
  The_Height := Height;
end;

constructor TUnlimitedBitmapImage.Create( AOwner : TComponent );
begin
  inherited Create( AOwner );
  TheBitmap := TBitmap.Create;
  TheULBMP := ULIFile_Bitmap.Create;
end;

destructor TUnlimitedBitmapImage.Destroy;
begin
  TheBitmap.Free;
  TheULBMP.Free;
  inherited Destroy;
end;

procedure TUnlimitedBitmapImage.LoadULBMPFile;
begin
  Valid_Load := false;
  if not FileExists( TheFileName ) then
  begin
    MessageDlg( TheFileName + ' cannot be found!',mterror,[mbOK],0);
    exit;
  end;
  Screen.Cursor := crHourGlass;
  TheULBMP.Initialize( TheFileName );
  TheULBMP.Load_Bitmap_File;
  TheBitmap.Handle := TheULBMP.Bitmap_Handle;
  TheBitmap.Height := TheULBMP.Height;
  TheBitmap.Width := TheULBMP.Width;
  Screen.Cursor := crDefault;
  oldFileName := TheFileName;
  valid_load := true;
end;

procedure TUnlimitedBitmapImage.Paint;
begin
  if csDesigning in ComponentState then
  begin
    inherited Paint;
    exit;
  end;
  if TheFileName = '' then
  begin
    inherited Paint;
    exit;
  end;
  if oldfilename <> Thefilename then
  begin
    LoadULBMPFile;
    if not Valid_load then
    begin
      Picture.Bitmap.Height := 0;
      Picture.Bitmap.Width := 0;
      inherited Paint;
      exit;
    end;
    Picture.Bitmap.Height := TheBitmap.Height;
    Picture.Bitmap.Width := TheBitmap.Width;
    Picture.Bitmap.Handle := TheBitmap.Handle;
    inherited Paint;
    exit;
  end;
  inherited Paint;
end;

procedure Register;
begin
  RegisterComponents('Widgets', [TUnlimitedBitmapImage]);
end;

end.